home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / scm / jackal1a.lha / jacal / types.scm < prev    next >
Encoding:
Text File  |  1992-12-24  |  11.5 KB  |  343 lines
  1. ;;; JACAL: Symbolic Mathematics System.        -*-scheme-*-
  2. ;;; Copyright 1989, 1990, 1991, 1992 Aubrey Jaffer.
  3. ;;; See the file "COPYING" for terms applying to this program.
  4.  
  5. ;;; We define proc so that scl.lisp will correctly funcallize it.
  6. (define proc 'proc)
  7.  
  8. ;;; Scheme doesn't allow for definition of new types which are
  9. ;;; distinct from existing types.  So we will carefully use BUNCH
  10. ;;; instead of LIST in order to distinguish the types. 
  11. ;;; This requires that boolean?, pair?, symbol?, number?,
  12. ;;; string?, vector? and procedure? be disjoint as outlined in:
  13. ;;; Jonathan Rees and William Clinger, editors. The Revised^3
  14. ;;; Report on the algorithmic language Scheme, ACM SIGPLAN Notices
  15. ;;; 21(12), ACM, December 1986.
  16. ;;; If the types are not disjoint you WILL lose.
  17.  
  18. ;;; The following types are mutually exclusive:
  19. ;;; SEXP, VARIABLE, EXPL, IMPL, EQLT, BUNCH
  20. ;;; INTEGERs are EXPL
  21. ;;; An EXPR is an EXPL or IMPL
  22. ;;; A LICIT is an EXPL, IMPL, or EQLT.
  23. ;;; VARIBLEs can only occur as part of EXPRS and EQLTS.
  24. ;;; SYMBOLs can only occur in SEXP.
  25. ;;; BUNCHES can contain SYMBOLs, LICITs, and BUNCHEs.
  26. ;;; An EXPL, IMPL, or EQLT, or BUNCH of these can be a
  27. ;;; lambda expression. 
  28.  
  29. ;;; A VAR is a vector which consists of:
  30. ;;; 0 var->sexp        - s-expression    ;lambda vars have leading "@"
  31.                     ;shadowed vars have leading ":"
  32. ;;; 1 var_pri         - string    ;ordering priority
  33.                     ;first char is priority override
  34.                     ;last char is differential order
  35. ;;; 2 var_def        - poleq        ;ext defining equation
  36. ;;;             or    - integer    ;lambda position
  37. ;;;             or - procedure    ;
  38. ;;; 3 var_depends    - list of vars    ;vars used in var_def
  39. ;;;;           THE REST ARE FOR FUNCTIONS ONLY
  40. ;;; 4 func-arglist            ;list of argument names.
  41. ;;; 5 func-parity    - list        ;EVEN, ODD, 0, or #F
  42. ;;; 6 func-syms        - list of lists    ;of positions of arguments
  43. ;;; 7 func-anti-syms    - list of lists    ;of positions of arguments
  44. ;;; 8 func-dists    - list of lists    ;of functions which distribute
  45. ;;; 9 func-anti-dists    - list of lists    ;of functions which anti-distribute
  46. ;;; 10 func-idems    - list        ;of positions of arguments
  47.                     ; perserved in idempotency
  48.  
  49. (define poly_var? vector?)
  50. (define (var->sexp v) (vector-ref v 0))
  51. (define (var_pri v) (char->integer (string-ref (vector-ref v 1) 0)))
  52. (define (var_set-pri! v i) (string-set! (vector-ref v 1) 0 (integer->char i)))
  53. (define (var_def v) (vector-ref v 2))
  54. (define (var_set-def! v i) (vector-set! v 2 i) v)
  55. (define (var_depends v) (vector-ref v 3))
  56. (define (var_set-depends! v i) (vector-set! v 3 i) v)
  57. (define (func-arglist f) (vector-ref f 4))
  58. (define (func-set-arglist f i) (vector-set! f 4 i))
  59.  
  60. (define func? func-arglist)
  61.  
  62. (define (func-parity f) (vector-ref f 5))
  63. (define (func-syms f) (vector-ref f 9))
  64. (define (func-anti-syms f) (vector-ref f 10))
  65. (define (func-dists f) (vector-ref f 11))
  66. (define (func-anti-dists f) (vector-ref f 12))
  67. (define (func-idems f) (vector-ref f 13))
  68.  
  69. (define (var_> v2 v1)
  70.   (string>? (vector-ref v2 1) (vector-ref v1 1)))
  71.  
  72. (define var-tab (make-hash-table 43))
  73. (define var-tab-lookup (predicate->hash-asso equal?))
  74. (define var-tab-define (hash-associator equal?))
  75.  
  76. (define (sexp->var sexp)
  77.   (let ((vcell (var-tab-lookup sexp var-tab)))
  78.     (if vcell (cdr vcell)
  79.     (let ((val (make-var sexp)))
  80.       (var-tab-define var-tab sexp val)
  81.       val))))
  82. (define (string->var s) (sexp->var (string->symbol s)))
  83. (define (deferop name . args)
  84.   (var->expl (sexp->var (cons name (map math->sexp args)))))
  85.  
  86. (define lambda-var-pri (+ -5 char-code-limit))
  87. (define lambda-var-pri-str (string (integer->char lambda-var-pri)))
  88. (define median-pri-str (string (integer->char (quotient char-code-limit 2))))
  89.  
  90. (require 'object->string)
  91. (define (make-var v)
  92.   (let ((base v)
  93.     (diffs 0))
  94.     (do () ((not (and (pair? base) (eq? 'differential (car base)))))
  95.       (set! base (cadr base))
  96.       (set! diffs (+ 1 diffs)))
  97.     (let* ((s (object->string base))
  98.        (sl (string-length s)))
  99.       (vector v
  100.           (string-append (case (string-ref s 0)
  101.                    ((#\@ #\:) lambda-var-pri-str)
  102.                    (else median-pri-str))
  103.                  s
  104.                  (string (integer->char diffs)))
  105.           (if (and (char=? #\@ (string-ref s 0))
  106.                (not (= sl 1))
  107.                (not (char=? #\^ (string-ref s 1))))
  108.           (string->number (substring s 1 sl))
  109.           #f)
  110.           #f))))
  111.  
  112. ;;; This checks for unshadowing :@
  113. ;(define (var->symbol v)
  114. ;  (let ((s (var->sexp-string v)))
  115. ;    (string->symbol
  116. ;     (string-append (if (char=? #\: (string-ref s 0))
  117. ;            (substring s 1 (string-length s))
  118. ;            s)
  119. ;            (make-string (var_diff-depth v) #\')))))
  120.  
  121. (define (var->string v)
  122.   (let ((sexp (var->sexp v)))
  123.     (math-assert (symbol? sexp) "expected simple symbol" sexp)
  124.     (symbol->string sexp)))
  125.  
  126. (define (make-rad-var radicand n)
  127.   (let ((e (univ_monomial -1 n _@)))
  128.     (set-car! (cdr e) radicand)
  129.     (let ((v (defext (sexp->var (list '^ (poly->sexp radicand) (list '/ 1 n)))
  130.            e)))
  131.       (set! radical-defs (cons (extrule v) radical-defs))
  132.       v)))
  133.  
  134. (define (make-subscripted-var v . indices)
  135.   (string->var
  136.    (apply string-append (var->string v)
  137.       (map (lambda (i) (string-append "_" (number->string i)))
  138.            indices))))
  139.  
  140. (define (var_nodiffs v)
  141.   (do ((base (vector-ref v 0) (cadr base)))
  142.       ((not (and (pair? base) (eq? 'differential (car base))))
  143.        (if (eq? base (vector-ref v 0)) v (sexp->var base)))))
  144. (define (var_differential? v)
  145.   (not (zero? (var_diff-depth v))))
  146. (define (var_diff-depth v)
  147.   (let ((s (vector-ref v 1)))
  148.     (char->integer (string-ref s (+ -1 (string-length s))))))
  149. (define (var_differential v)
  150.   (sexp->var (list 'differential (var->sexp v))))
  151. (define (var_undiff v)
  152.   (sexp->var (cadr (var->sexp v))))
  153.  
  154. (define (lambdavar? v)
  155.   (= lambda-var-pri (var_pri v)))
  156. (define (lambda-var i diff-depth)
  157.   (if (zero? diff-depth) 
  158.       (var_set-def! (sexp->var
  159.              (string->symbol
  160.               (string-append "@" (number->string i))))
  161.             i)
  162.       (var_differential (lambda-var i (+ -1 diff-depth)))))
  163. ;;; This sometimes is called with shadowed variables (:@4)
  164. (define lambda-position var_def)
  165. (define (var->sexp-string v)
  166.   (var->string (var_nodiffs v)))
  167. (define (var->sexp-apply proc var)
  168.   (if (var_differential? var)
  169.       (var_differential (var->sexp-apply proc (var_undiff var)))
  170.       (apply proc var '())))
  171. (define (var_shadow v)
  172.   (var->sexp-apply (lambda (v)
  173.             (var_set-def!
  174.              (string->var (string-append ":" (var->sexp-string v)))
  175.              (var_def v)))
  176.           v))
  177.  
  178. (define (extrule e) (and (pair? (var_def e)) (var_def e)))
  179. (define (defext var impl)
  180.   (let ((fees '()) (deps '()))
  181.     (poly_for-each-var
  182.      (lambda (v) (if (not (_@? v)) (if (extrule v)
  183.                        (set! fees (adjoin v fees))
  184.                        (set! deps (adjoin v deps)))))
  185.      impl)
  186.     (for-each (lambda (fee) (set! deps (union (var_depends fee) deps)))
  187.           fees)
  188.     (var_set-depends! var deps)
  189.     (set! fees (nconc fees deps))
  190.     (var_set-pri! var (if (null? fees) 10 ;must be a constant.
  191.               (+ 1 (apply max (map var_pri fees)))))
  192.     (var_set-def! var (vsubst var _@ impl))
  193.     var))
  194.  
  195. ;;; IMPL is a data type consisting of a poly with major variable
  196. ;;; _@.  The value of the IMPL is negative of the poly solved for _@.
  197. ;;; Using this representation, if poly is square-free and has no
  198. ;;; content (gcd (coefficients) = 1), we can express any
  199. ;;; algebraic function or number uniquely, even those with no standard
  200. ;;; representation (order > 4 roots).
  201.  
  202. (define (expr? p)
  203.   (or (number? p)
  204.       (and (pair? p)
  205.        (poly_var? (car p)))))
  206. (define (impl? p) (and (pair? p) (poly_var? (car p)) (_@? (car p))))
  207. (define (rat_number? p)
  208.   (or (number? p)
  209.       (and (impl? p)
  210.        (= 3 (length p))
  211.        (number? (cadr p))
  212.        (number? (caddr p)))))
  213. (define (expr_0? p) (or (eqv? 0 p) (and (impl? p) (eqv? 0 (rat_num p)))))
  214. (define (expl? p)
  215.   (or (number? p)
  216.       (and (pair? p)
  217.        (poly_var? (car p))
  218.        (not (_@? (car p))))))
  219. ;;; Rational impl?
  220. (define (rat? p) (and (impl? p) (= 3 (length p))))
  221. (define (make-rat num denom) (list _@ num (poly_negate denom)))
  222. (define rat_num cadr)
  223. (define (rat_denom p) (poly_negate (caddr p)))
  224. (define (rat_unit-denom? p) (unit? (caddr p)))
  225.  
  226. (define (bunch? p)
  227.   (or (null? p)
  228.       (and (pair? p)
  229.        (not (poly_var? (car p)))
  230.        (not (eqv? _@= (car p))))))
  231. (define (bunch_map proc b)
  232.   (if (bunch? b)
  233.       (map (lambda (x) (bunch_map proc x)) b)
  234.     (proc b)))
  235. (define (bunch_for-each proc b)
  236.   (if (bunch? b)
  237.       (for-each (lambda (x) (bunch_for-each proc x)) b)
  238.     (proc b)))
  239.  
  240. (define _@= "=")
  241. (define (eqn? p) (and (pair? p) (eqv? _@= (car p))))
  242. (define (eqns? p) (if (bunch? p) (some eqns? p) (eqn? p)))
  243. (define (licit? p)
  244.   (or (number? p)
  245.       (and (pair? p)
  246.        (or (poly_var? (car p))
  247.            (eqv? _@= (car p))))))
  248.  
  249. (define eqn->poly cdr)
  250. (define (poly->eqn p) (cons _@= p))
  251. (define (polys->eqns p) (if (bunch? p) (map polys->eqns p) (poly->eqn p)))
  252. (define (var->expl v) (list v 0 1))
  253. (define (expl->impl p) (make-rat p 1))
  254. (define (var->impl v) (make-rat (var->expl v) 1))
  255.  
  256. ;;; Two paradigms for doing algebra on equations and expressions:
  257. ;;; Polynomials as expressions and Polynomials as equations.
  258. ;;; Polynomials are used as expressions in GCD.
  259. ;;; Polynomials are used as equations in ELIMINATE.
  260. ;;;    licit->    polxpr    poleqn
  261. ;;;    eqn    expl    expl
  262. ;;;    expl    expl    impl
  263. ;;;    impl    expl(?)    impl
  264. ;;; After the operation is done, we need to convert back.  For
  265. ;;; Polynomials as expressions, the result is already expl.  For
  266. ;;; polynomials as equations:
  267. ;;;     poleqn->licit
  268. ;;;    expl    eqn
  269. ;;;    impl    expr
  270. (define (licit->poleqn p)
  271.   (cond ((symbol? p) (var->impl (sexp->var p)))
  272.     ((eqn? p) (eqn->poly p))
  273.     ((impl? p) p)
  274.     ((expl? p) (expl->impl p))
  275.     (else (math-error "cannot be coerced to implicit: " p))))
  276. (define (licits->poleqns p)
  277.   (if (bunch? p) (map licits->poleqns p) (licit->poleqn p)))
  278. (define (poleqn->licit p)
  279.   (cond ((impl? p) (expr_norm p))
  280.     ((expl? p) (poly->eqn p))
  281.     (else (math-error "not a polynomial equation" p))))
  282. (define (poleqns->licits p)
  283.   (if (bunch? p) (map poleqns->licits p) (poleqn->licit p)))
  284. (define (licit->polxpr p)
  285.   (cond ((symbol? p) (var->expl (sexp->var p)))
  286.     ((eqn? p) (eqn->poly p))
  287.     ((expl? p) p)
  288.     ((and (impl? p) (poly_/? (rat_num p) (rat_denom p))))
  289.     (else (math-error "cannot be coerced to explicit: " p))))
  290. (define (expr p)
  291.   (cond ((symbol? p) (var->expl (sexp->var p)))
  292.     ((expr? p) p)
  293.     (else (math-error "cannot be coerced to expr: " p))))
  294. (define (exprs p)
  295.   (if (bunch? p) (map exprs p) (expr p)))
  296. (define (explicit->var p)
  297.   (cond ((symbol? p) (sexp->var p))
  298. ;    ((poly_var? p) p)
  299.     ((and (pair? p)
  300.           (expl? p)
  301.           (equal? (cdr p) '(0 1)))
  302.      (car p))
  303.     (else (math-error "not a simple variable: " p))))
  304. (define (variables p)
  305.   (cond ((symbol? p) (list (sexp->var p)))
  306. ;    ((poly_var? p) (list p))
  307.     ((and (pair? p)
  308.           (expl? p)
  309.           (equal? (cdr p) '(0 1)))
  310.      (list (car p)))
  311.     ((list? p) (map explicit->var p))
  312.     ((else (math-error "not a simple variable: " p)))))
  313. (define (plicit->integer p)
  314.   (cond ((integer? p) p)
  315.     ((not (rat_number? p)) (math-error "not an integer " p))
  316.     ((rat_unit-denom? p) (* (rat_denom p) (rat_num p) -1))
  317.     (else (math-error "not an integer " p))))
  318. (define (unit? x) (member x '(1 -1)))
  319. (define (expr_norm p)
  320.   (if (and (rat? p) (rat_unit-denom? p))
  321.       (poly_* (rat_num p) (rat_denom p))
  322.     p))
  323. (define (expr_norm-or-signcan p)
  324.   (if (and (rat? p) (rat_unit-denom? p))
  325.       (poly_* (rat_num p) (rat_denom p))
  326.       (signcan p)))
  327.  
  328. ;;; These two functions return type expl
  329. (define (num p)
  330.   (cond ((impl? p) (rat_num p))
  331.     ((expl? p) p)
  332.     (else (math-error "cannot extract numerator " p))))
  333. (define (denom p)
  334.   (cond ((rat? p) (rat_denom p))
  335.     ((expl? p) 1)
  336.     (else (math-error "cannot extract denominator " p))))
  337. (define (sexp? e)
  338.   (cond ((number? e) #t)
  339.     ((symbol? e) #t)
  340.     ((pair? e) (symbol? (car e)))
  341.     ((vector? e) #t)
  342.     (else #f)))
  343.